home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Toolbox / Visual Basic Toolbox (P.I.E.)(1996).ISO / dialog / demo3d / module1.bas < prev    next >
BASIC Source File  |  1995-03-24  |  14KB  |  400 lines
  1. Option Explicit
  2.  
  3. 'Compiled by:  M. John Rodriguez,  CIS ID: 100321,620
  4. '                             Internet ID: jrodrigu@cpd.hqusareur.army.mil
  5. '                                        : 100321.620@compuserve.com
  6. '
  7. 'Please feel free to distribute this for your use and experiments.  Please ensure
  8. 'that you give credit to the folks who unknowingly helped to do this.
  9. '
  10. '
  11. 'This procedures contained in this module are the culmination of work supplied by various
  12. 'individuals.  It would not be proper for me not to include their names.  To make it easier
  13. 'to tell who authored what, their names are commented in the appropriate procedures.
  14. '
  15. ' Module contains:
  16. ' App3DRegister     - call this when you first begin your application
  17. ' App3DUnregister   - call this just before you exit.
  18. ' ComboBoxIn3D      - for combo boxes, called by FormIn3D
  19. ' ControlIn3D       - for most controls, called by FormIn3D
  20. ' Dlg3DRegister     - call this when you load your dialog form
  21. ' Dlg3DUnregister   - call this when you unload the dialog form
  22. ' DlgIn3D           - call this to set your dialog window attributes for CTL3D
  23. ' DlgSysMenu        - removes the last entries in the system menu.  Make sure that
  24. '                     you set the MinButton and MaxButton properties to false so
  25. '                     you wont have to look at the Restore, Minimize, and Maximize entries
  26. '                     just shows the Move and Close menu items
  27. ' ExitProgram       - Performs the cleanup for the application.. nothing exciting...
  28. ' FormIn3D          - adds 3D appearance to VB's controls - does not use CTL3D
  29. ' LineIn3D          - for graphic lines, called by FormIn3D
  30. ' Main              - demonstrates that you don't need to start off with a form to use CTL3D
  31. '
  32. '
  33. '
  34. 'CTL3D API calls... If you don't have CTL3DV2.DLL, you can delete the V2 and it should
  35. 'still work properly.
  36. Declare Function Ctl3dAutoSubclass Lib "Ctl3DV2.DLL" (ByVal hInst As Integer) As Integer
  37. Declare Function Ctl3dRegister Lib "Ctl3DV2.DLL" (ByVal hInst As Integer) As Integer
  38. Declare Function Ctl3dUnregister Lib "Ctl3DV2.DLL" (ByVal hInst As Integer) As Integer
  39. Declare Function Ctl3dSubclassDlgEx Lib "Ctl3DV2.DLL" (ByVal hWnd As Integer, dFlags As Long) As Integer
  40.  
  41.  
  42. 'Other API Calls for the Forms...
  43. Declare Function GetModuleHandle Lib "Kernel" (ByVal ModuleName As String) As Integer
  44. Declare Function GetWindowLong Lib "User" (ByVal hWnd As Integer, ByVal nIndex As Integer) As Long
  45. Declare Function GetWindowWord Lib "User" (ByVal hWnd As Integer, ByVal nIndex As Integer) As Integer
  46. Declare Function SetWindowLong Lib "User" (ByVal hWnd As Integer, ByVal nIndex As Integer, ByVal dwNewLong As Long) As Long
  47.  
  48. Global Const BUTTON_FACE = &H8000000F
  49. Global Const FIXED_DOUBLE = 3
  50. Global Const DS_MODALFRAME = &H80&
  51. Global Const GWL_STYLE = (-16)
  52. Global Const GWW_HINSTANCE = (-6)
  53. Global Const CTL3D_ALL = &HFFFF
  54.  
  55. 'Menu API's for adjusting the 3D Dialog box system menu...
  56. Declare Function GetSystemMenu% Lib "User" (ByVal hWnd%, ByVal bRevert%)
  57. Declare Function RemoveMenu% Lib "User" (ByVal hMenu%, ByVal nPosition%, ByVal wFlags%)
  58. Global Const MF_BYPOSITION = &H400
  59.  
  60. 'Some colors for us to use...
  61. Global Const COLOR_BLACK = &H0&
  62. Global Const COLOR_LIGHT_GRAY = &HC0C0C0
  63. Global Const COLOR_DARK_GRAY = &H808080
  64. Global Const COLOR_WHITE = &HFFFFFF
  65.  
  66. '/* Ctl3d Control ID */
  67. Global Const CTL3D_BUTTON_CTL = 0
  68. Global Const CTL3D_LISTBOX_CTL = 1
  69. Global Const CTL3D_EDIT_CTL = 2
  70. Global Const CTL3D_COMBO_CTL = 3
  71. Global Const CTL3D_STATIC_CTL = 4
  72.  
  73. 'This is for the application itself.  You need for your whole application.
  74. 'Otherwise, you won't get 3D Message Boxes and common dialogs.
  75. '
  76. Sub App3DRegister ()
  77.  
  78. Dim appInst%, suc%, appname$
  79.  
  80. appname$ = App.EXEName
  81.  
  82. 'Get the application instance...
  83. appInst% = GetModuleHandle(appname$)
  84. 'Now register the application
  85. suc% = Ctl3dRegister(appInst%)
  86. 'now subclass all of the dialog and message boxes
  87. suc% = Ctl3dAutoSubclass(appInst%)
  88.  
  89. End Sub
  90.  
  91. 'Before you exit your application, give this procedure a call..
  92. 'In this case, I have a procedure called ExitProgram() that allows
  93. 'me to do all of my cleanup functions.  This procedure is in there.
  94. '
  95. Sub App3DUnregister ()
  96.  
  97. 'Call this just before your application exits..
  98.  
  99. Dim appInst%, suc%, appname$
  100.  
  101. appname$ = App.EXEName
  102.  
  103. 'Get the application instance again..
  104. appInst% = GetModuleHandle(appname$)
  105.  
  106. 'Now unregister us...
  107. suc% = Ctl3dUnregister(appInst%)
  108.  
  109. End Sub
  110.  
  111. Sub CenterForm (f As Form)
  112.  
  113. Dim iTop As Integer, iLeft As Integer
  114.  
  115. 'Make sure we are normal..
  116. If f.WindowState <> 0 Then Exit Sub
  117.  
  118. 'Get the top and left coordinates for the form to be in the center
  119. iTop = (Screen.Height - f.Height) \ 2
  120. iLeft = (Screen.Width - f.Width) \ 2
  121.  
  122. 'Now move us there..
  123. f.Move iLeft, iTop
  124.  
  125. End Sub
  126.  
  127. '
  128. ' ControlIn3D paints a 3D-border around the control given in ctrlTarget.
  129. ' nBevel controls the the deepness, nSpace the distance between the control
  130. ' and the 3D-border and bInset sets the border to be drawn inset or outset.
  131. '
  132. ' Parts of this code are taken from the VB Tips & Tricks help file.
  133. ' Original code written by Matej Nastran.
  134. '
  135. '
  136. Sub ComboBoxIn3D (ctrlCombo As Control, nBevel As Integer)
  137.     
  138.     Dim PixelX As Integer, PixelY As Integer
  139.     Dim CTop As Integer, CRight As Integer, CBottom As Integer
  140.  
  141.     ' Just put "No 3D" in the Tag property and your ComboBox keeps 2D
  142.     If InStr(UCase(ctrlCombo.Tag), "NO 3D") = 0 Then
  143.     
  144.     ControlIn3D ctrlCombo, nBevel, 0, True
  145.     
  146.     If ctrlCombo.Style = 0 Then             'Remove white space only
  147.         PixelX = Screen.TwipsPerPixelX      'if it is a Dropdown ComboBox
  148.         PixelY = Screen.TwipsPerPixelY
  149.         CTop = ctrlCombo.Top
  150.         CRight = ctrlCombo.Left + ctrlCombo.Width
  151.         CBottom = ctrlCombo.Top + ctrlCombo.Height
  152.         ctrlCombo.Parent.Line (CRight - PixelX * 24, CTop)-(CRight - PixelX * 18, CBottom - PixelY), COLOR_LIGHT_GRAY, BF
  153.     End If
  154.     End If
  155.  
  156. End Sub
  157.  
  158. '
  159. '
  160. ' ControlIn3D paints a 3D-border around the control given in ctrlTarget.
  161. ' nBevel controls the the deepness, nSpace the distance between the control
  162. ' and the 3D-border and bInset sets the border to be drawn inset or outset.
  163. '
  164. ' Parts of this code are taken from the VB Tips & Tricks help file.
  165. ' Original code written by Matej Nastran.
  166. '
  167. Sub ControlIn3D (ctrlTarget As Control, nBevel As Integer, nSpace As Integer, bInset As Integer)
  168.     Dim CTop As Integer, CLeft As Integer, CRight As Integer, CBottom As Integer
  169.     Dim PixelX As Integer, PixelY As Integer, AddX As Integer, AddY As Integer
  170.     Dim i As Integer
  171.  
  172.     ' Just put "No 3D" in the Tag property and your control keeps 2D
  173.     If InStr(UCase(ctrlTarget.Tag), "NO 3D") = 0 Then
  174.     PixelX = Screen.TwipsPerPixelX
  175.     PixelY = Screen.TwipsPerPixelY
  176.     CTop = ctrlTarget.Top - PixelY
  177.     CLeft = ctrlTarget.Left - PixelX
  178.     CRight = ctrlTarget.Left + ctrlTarget.Width
  179.     CBottom = ctrlTarget.Top + ctrlTarget.Height
  180.     If bInset Then          ' Draw border inset
  181.         For i = nSpace To (nBevel + nSpace - 1)
  182.         AddX = i * PixelX: AddY = i * PixelY
  183.         ctrlTarget.Parent.Line (CLeft - AddX, CTop - AddY)-(CRight + AddX, CTop - AddY), COLOR_DARK_GRAY
  184.         ctrlTarget.Parent.Line (CLeft - AddX, CTop - AddY)-(CLeft - AddX, CBottom + AddY), COLOR_DARK_GRAY
  185.         ctrlTarget.Parent.Line (CLeft - AddX, CBottom + AddY)-(CRight + AddX + PixelX, CBottom + AddY), COLOR_WHITE
  186.         ctrlTarget.Parent.Line (CRight + AddX, CTop - AddY)-(CRight + AddX, CBottom + AddY), COLOR_WHITE
  187.         Next i
  188.     Else                    ' Draw border outset
  189.         For i = nSpace To (nBevel + nSpace - 1)
  190.         AddX = i * PixelX: AddY = i * PixelY
  191.         ctrlTarget.Parent.Line (CRight + AddX, CBottom + AddY)-(CRight + AddX, CTop - AddY), COLOR_DARK_GRAY
  192.         ctrlTarget.Parent.Line (CRight + AddX, CBottom + AddY)-(CLeft - AddX, CBottom + AddY), COLOR_DARK_GRAY
  193.         ctrlTarget.Parent.Line (CRight + AddX, CTop - AddY)-(CLeft - AddX - PixelX, CTop - AddY), COLOR_WHITE
  194.         ctrlTarget.Parent.Line (CLeft - AddX, CBottom + AddY)-(CLeft - AddX, CTop - AddY), COLOR_WHITE
  195.         Next i
  196.     End If
  197.     End If
  198.  
  199. End Sub
  200.  
  201. 'Call this procedure for each form.  This is my add on to the the other code
  202. 'presented.  I had a hard time with this but I was able to deduce two important
  203. 'facts.
  204. '1)  VB Forms in by themselves are independent entities of each other in the
  205. 'VB environment.  That means for each form to work, you have to at a minimum
  206. 'register it with CTL3D.
  207. '
  208. '2) Once you Initialize your Autosubclass for the app, you don't have to do it with
  209. 'each dlg because the main application has already done it.  Solves the
  210. 'global application problem of having 3D Dialogs and Message Boxes and eliminates a GPF if
  211. 'you try to autosubclass once you already have done it.
  212. '
  213. Sub Dlg3DRegister (fm As Form)
  214.  
  215. Dim dlgInst%, suc%
  216.  
  217. 'Get the forms instance for this case
  218. dlgInst% = GetWindowWord(fm.hWnd, GWW_HINSTANCE)
  219.  
  220. 'Register the dialog
  221. suc% = Ctl3dRegister(dlgInst%)
  222.  
  223.  
  224. End Sub
  225.  
  226. ' Once you finish with the dialog, call this procedure in the form_unload
  227. ' event to deregister the dialog box.
  228. '
  229. Sub Dlg3DUnregister (fm As Form)
  230.  
  231. Dim dlghInst%, suc%
  232.  
  233. 'Get the instance of the dialog
  234. dlghInst% = GetWindowWord(fm.hWnd, GWW_HINSTANCE)
  235.  
  236. 'Unregister it..
  237. suc% = Ctl3dUnregister(dlghInst%)
  238.  
  239.  
  240. End Sub
  241.  
  242. 'This procedure makes my dialog box appear 3D.
  243. '
  244. 'This snippet of code was taken by a submission from
  245. 'RANDRIAMBOLOLONA Roland H. - Compuserve ID - 100331,2516
  246. '
  247. 'He says he got some of it from the MARCH '95 VBPJ  Code Listing - TIPS.TXT
  248. '
  249. 'This procedure was not commented, I am just telling you where I got the source
  250. 'for this because it works very well...
  251. '
  252. Sub DlgIn3D (frm As Form)
  253.  
  254.     Dim hWnd As Integer
  255.     Dim iResult As Integer
  256.     Dim lStyle As Long
  257.  
  258.     hWnd = frm.hWnd
  259.     If frm.BorderStyle = FIXED_DOUBLE Then
  260.     frm.BackColor = BUTTON_FACE
  261.     lStyle = GetWindowLong(hWnd, GWL_STYLE)
  262.     lStyle = lStyle Or DS_MODALFRAME
  263.     lStyle = SetWindowLong(hWnd, GWL_STYLE, lStyle)
  264.     iResult = Ctl3dSubclassDlgEx(hWnd, &H0)
  265.     End If
  266.  
  267. End Sub
  268.  
  269. 'This procedure modifies the menu for the dialog box.
  270. 'In order for this to work correctly, the form must have the MinButton and MaxButton set
  271. 'to false if you leave the ControlBox property set to true.  Otherwise, Restore, Maximize, and
  272. 'Minimize will stay on...
  273. '
  274. 'This snippet of code was taken by a submission from
  275. 'RANDRIAMBOLOLONA Roland H. - Compuserve ID - 100331,2516
  276. '
  277. 'He says he got some of it from the MARCH '95 VBPJ  Code Listing - TIPS.TXT
  278. '
  279. 'The author did not say if he did this, I am passing the accolades - with a few
  280. 'modifications for readability
  281. '
  282. Sub DlgSysMenu (fm As Form)
  283.  
  284. Dim hSysMenu%, suc%
  285.  
  286. ' Obtain the handle to the forms System menu
  287. hSysMenu% = GetSystemMenu(fm.hWnd, False)
  288.  
  289. ' Remove all but the MOVE and CLOSE options.  The menu items
  290. ' must be removed starting with the last menu item.
  291. '
  292. suc% = RemoveMenu(hSysMenu, 8, MF_BYPOSITION) 'Switch to
  293. suc% = RemoveMenu(hSysMenu, 7, MF_BYPOSITION) 'Separator
  294. suc% = RemoveMenu(hSysMenu, 5, MF_BYPOSITION) 'Separator
  295.  
  296.  
  297. End Sub
  298.  
  299. Sub ExitProgram ()
  300.  
  301. App3DUnregister
  302.  
  303. End
  304.  
  305.  
  306. End Sub
  307.  
  308. '
  309. ' FormIn3D paints a 3D-border around controls on the given Form frmTarget.
  310. ' nBevel controls the the deepness of the 3D-border. bBlaster parameter removed,
  311. ' don't need it in this case.
  312. '
  313. ' Controls that are affected:
  314. '       TextBox         ListBox         ComboBox
  315. '       DriveListBox    DirListBox      FileListBox
  316. '       Line
  317. '       ... (list can be easly expanded)
  318. '
  319. ' Just put "No 3D" in the Tag property of a specific control or the form
  320. ' itself and it is not painted in 3D.
  321. '
  322. ' Call this function from your forms Paint-event.
  323. '
  324. ' Parts of this code are taken from the VB Tips & Tricks help file.
  325. ' Original code written by Matej Nastran.
  326. '
  327. Sub FormIn3D (frmTarget As Form, nBevel As Integer)
  328.     Dim DrawWidthOld As Integer, ScaleModeOld As Integer
  329.     Dim i As Integer, Ret As Integer
  330.     Dim ctrlTarget As Control
  331.     Static bBusy As Integer
  332.     
  333.  
  334.     If bBusy Then Exit Sub          'Got some DoEvents. Just in case...
  335.     bBusy = True
  336.  
  337.     DrawWidthOld = frmTarget.DrawWidth
  338.     frmTarget.DrawWidth = 1
  339.     ScaleModeOld = frmTarget.ScaleMode
  340.     frmTarget.ScaleMode = 1     'Twips
  341.  
  342.     DoEvents
  343.     
  344.     'Loop controls
  345.     For i = 0 To (frmTarget.Controls.Count - 1)
  346.     Set ctrlTarget = frmTarget.Controls(i)
  347.     If TypeOf ctrlTarget Is TextBox Then ControlIn3D ctrlTarget, nBevel, 0, True
  348.     If TypeOf ctrlTarget Is ListBox Then ControlIn3D ctrlTarget, nBevel, 0, True
  349.     If TypeOf ctrlTarget Is ComboBox Then   'ComboBoxes are special
  350.         ComboBoxIn3D ctrlTarget, nBevel
  351.     End If
  352.     If TypeOf ctrlTarget Is DriveListBox Then ControlIn3D ctrlTarget, nBevel, 0, True
  353.     If TypeOf ctrlTarget Is DirListBox Then ControlIn3D ctrlTarget, nBevel, 0, True
  354.     If TypeOf ctrlTarget Is FileListBox Then ControlIn3D ctrlTarget, nBevel, 0, True
  355.     If TypeOf ctrlTarget Is Line Then       'Lines are also special
  356.         LineIn3D ctrlTarget
  357.     End If
  358.     If TypeOf ctrlTarget Is Label Then ControlIn3D ctrlTarget, nBevel, 0, True
  359.     Next i
  360.     
  361.     frmTarget.DrawWidth = DrawWidthOld      'Always restore what you change
  362.     frmTarget.ScaleMode = ScaleModeOld
  363.     
  364.  
  365.     bBusy = False
  366.  
  367. End Sub
  368.  
  369. '
  370. ' LineIn3D paints the given Line-control ctrlLine in 3D.
  371. ' frmTarget is the Form containing that Line.
  372. '
  373. Sub LineIn3D (ctrlLine As Control)
  374.  
  375.     If InStr(UCase(ctrlLine.Tag), "NO 3D") = 0 Then
  376.     ctrlLine.BorderColor = COLOR_DARK_GRAY
  377.     'Check if line is vertical or horizontal
  378.     If Abs(ctrlLine.X2 - ctrlLine.X1) > Abs(ctrlLine.Y2 - ctrlLine.Y1) Then
  379.     ctrlLine.Parent.Line (ctrlLine.X1, ctrlLine.Y1 + Screen.TwipsPerPixelY)-(ctrlLine.X2, ctrlLine.Y2 + Screen.TwipsPerPixelY), COLOR_WHITE
  380.     Else
  381.     ctrlLine.Parent.Line (ctrlLine.X1 + Screen.TwipsPerPixelX, ctrlLine.Y1)-(ctrlLine.X2 + Screen.TwipsPerPixelX, ctrlLine.Y2), COLOR_WHITE
  382.     End If
  383.     End If
  384.  
  385. End Sub
  386.  
  387. Sub Main ()
  388.  
  389. 'First things first, register my application...
  390. App3DRegister
  391.  
  392.  
  393. 'Now show the first form...
  394. Form1.Show
  395.  
  396.  
  397.  
  398. End Sub
  399.  
  400.